unit ScriptModule;

interface

uses
  SysUtils, Classes, DB, Generics.Collections,
  dwsComp, dwsCompiler, dwsExprs, dwsExprList, dwsFunctions;

type
   TAccessor = class
   public
      procedure read(info: TProgramInfo; var value: Variant); virtual; abstract;
      procedure write(info: TProgramInfo; const value: Variant); virtual; abstract;
   end;

   TVarReadFunc = reference to function: Variant;
   TVarWriteProc = reference to procedure(const value: variant);
   TAccessType = (atReadWrite, atReadOnly, atWriteOnly);

   TFuncExecutor = class
   private
      FName: string;
   public
      constructor Create(const name: string);
      function FastEval(const args: TExprBaseListExec): Variant;
   end;

  TScripts = class(TDataModule)
    dws: TDelphiWebScript;
    externals: TdwsUnit;
    procedure DataModuleCreate(Sender: TObject);
    procedure DataModuleDestroy(Sender: TObject);
    function externalsFunctionsLegacyScriptFastEval(
      const args: TExprBaseListExec): Variant;
    function externalsFunctionsLegacyAliasFastEval(
      const args: TExprBaseListExec): Variant;
    function externalsFunctionsPrintVarsEval(
      const args: TExprBaseListExec): Variant;
    function externalsFunctionsPrintEval(
      const args: TExprBaseListExec): Variant;
    function externalsFunctionsDebugOutputEval(
      const args: TExprBaseListExec): Variant;
    function externalsFunctionsCommandEval(
      const args: TExprBaseListExec): Variant;
    function dwsNeedUnit(const unitName: string;
      var unitSource: string): IdwsUnit;
  private
    FAccessors: TObjectDictionary<string, TAccessor>;
    FAliases: TObjectList<TFuncExecutor>;
    FCurrentContext: integer;
    sVars: array[0..5] of string;
    procedure AddVar(const name: string);
    procedure AddSysVars;
    procedure AddVarInternal(const name: string; const accessor: TAccessor;
      accessType: TAccessType);
    procedure AddSysVar(const name: string; const reader: TVarReadFunc;
      const writer: TVarWriteProc);
    procedure AddSysCVar(const name: string; const reader: TVarReadFunc);
    procedure ResetFunctions;
    procedure LegacyScript(const script: string; kind: integer);
    procedure AddFunc(name: string);
  public
    procedure PrepareFunctions(dataset: TDataset);
    procedure PrepareVars(dataset: TDataset);
    function GetVarValue(const name: string; out value: variant): boolean;
    function GetVarValueAsString(const name: string): string;
    procedure SetVarValue(const name: string; const value: variant);

    procedure RunScript(const script: string);

    property CurrentContext: integer read FCurrentContext write FCurrentContext;
  end;

  EScriptError = class(Exception);

var
  Scripts: TScripts;

implementation
uses
   Variants, Character,
   Database, Main,
   dwsSymbols, dwsUtils;

{$R *.dfm}

type
   TVarAccessor = class(TAccessor)
   private
      FName: string;
   public
      constructor Create(const name: string);
      procedure read(info: TProgramInfo; var value: Variant); override;
      procedure write(info: TProgramInfo; const value: Variant); override;
   end;

   TSystemVarAccessor = class(TAccessor)
   private
      FReader: TVarReadFunc;
      FWriter: TVarWriteProc;
      FName: string;
   public
      constructor Create(const name: string; const reader: TVarReadFunc;
        const writer: TVarWriteProc);
      procedure read(info: TProgramInfo; var value: Variant); override;
      procedure write(info: TProgramInfo; const value: Variant); override;
   end;

{ TScripts }

procedure TScripts.DataModuleCreate(Sender: TObject);
begin
   FAccessors := TObjectDictionary<string, TAccessor>.Create([doOwnsValues]);
   FAliases := Generics.Collections.TObjectList<TFuncExecutor>.Create(true);
end;

procedure TScripts.DataModuleDestroy(Sender: TObject);
begin
   FAccessors.Free;
   FAliases.Free;
end;

function TScripts.dwsNeedUnit(const unitName: string;
  var unitSource: string): IdwsUnit;
begin
   unitSource := datawell.Tableunits.Lookup('Master;Name', VarArrayOf([datawell.masterinteger, unitName]), 'script');
end;

function TScripts.GetVarValue(const name: string; out value: variant): boolean;
var
   acc: TAccessor;
begin
   if FAccessors.TryGetValue(UpperCase(name), acc) then
   begin
      acc.read(nil, value);
      result := true
   end
   else result := false;
end;

function TScripts.GetVarValueAsString(const name: string): string;
var
   acc: TAccessor;
   value: variant;
begin
   if FAccessors.TryGetValue(UpperCase(name), acc) then
   begin
      acc.read(nil, value);
      result := value
   end
   else result := '';
end;

procedure TScripts.SetVarValue(const name: string; const value: variant);
var
   acc: TAccessor;
begin
   if FAccessors.TryGetValue(UpperCase(name), acc) then
      acc.write(nil, value);
end;

function SafeAliasName(name: string): string;
var
   i: Integer;
   ch: char;
begin
   result := name;
   for i := 1 to length(result) do
   begin
      ch := result[i];
      if (not TCharacter.IsLetterOrDigit(ch)) and (ch <> '_') then
         result[i] := '_';
   end;
end;

procedure TScripts.AddVarInternal(const name: string; const accessor: TAccessor;
   accessType: TAccessType);
var
   newVar: TdwsGlobal;
begin
   newVar := externals.Variables.Add;
   newVar.Name := safeAliasName(name);
   newVar.DataType := 'variant';
   if accessType <> atWriteOnly then
      newVar.OnReadVar := accessor.read;
   if accessType <> atReadOnly then
      newVar.OnWriteVar := accessor.write;
   FAccessors.add(UpperCase(name), accessor);
end;

procedure TScripts.AddVar(const name: string);
var
   accessor: TVarAccessor;
begin
   accessor := TVarAccessor.Create(name);
   AddVarInternal(name, accessor, atReadWrite);
end;

procedure TScripts.AddSysVar(const name: string; const reader: TVarReadFunc;
   const writer: TVarWriteProc);
var
   accessor: TSystemVarAccessor;
   at: TAccessType;
begin
   accessor := TSystemVarAccessor.Create(name, reader, writer);
   if not assigned(reader) then
      at := atWriteOnly
   else if not assigned(writer) then
      at := atReadOnly
   else at := atReadWrite;
   AddVarInternal(name, accessor, at);
end;

procedure TScripts.AddSysCVar(const name: string; const reader: TVarReadFunc);
begin
   AddSysVar(name, reader,
      procedure(const value: variant) begin FormMain.Compile(format('@%s=', [name]) + value) end)
end;

procedure TScripts.AddSysVars;
begin
   AddSysCVar('HP',
      function: variant begin result := FormMain.LabelHP.caption end);
   AddSysCVar('MAXHP',
      function: variant begin result := FormMain.LabelHPMax.caption end);
   AddSysCVar('SP',
      function: variant begin result := FormMain.LabelSP.caption end);
   AddSysCVar('MAXSP',
      function: variant begin result := FormMain.LabelSPMax.caption end);
   AddSysCVar('GP1',
      function: variant begin result := FormMain.LabelGP1.caption end);
   AddSysCVar('MAXGP1',
      function: variant begin result := FormMain.LabelGP1Max.caption end);
   AddSysCVar('GP2',
      function: variant begin result := FormMain.LabelGP2.caption end);
   AddSysCVar('MAXGP2',
      function: variant begin result := FormMain.LabelGP2Max.caption end);
   AddSysCVar('ENEMY',
      function: variant begin result := FormMain.GaugeEnemy.progress end);
   AddSysCVar('ENAME',
      function: variant begin result := FormMain.GetEName end);
   AddSysCVar('GLINE1',
      function: variant begin result := Datawell.gline1 end);
   AddSysCVar('GLINE2',
      function: variant begin result := Datawell.gline2 end);
   AddSysCVar('CAPTION',
      function: variant begin result := FormMain.Caption end);
   AddSysVar('AA',
      function: variant begin result := sVars[0] end,
      procedure(const value: variant) begin sVars[0] := value end);
   AddSysVar('BB',
      function: variant begin result := sVars[1] end,
      procedure(const value: variant) begin sVars[1] := value end);
   AddSysVar('CC',
      function: variant begin result := sVars[2] end,
      procedure(const value: variant) begin sVars[2] := value end);
   AddSysVar('DD',
      function: variant begin result := sVars[3] end,
      procedure(const value: variant) begin sVars[3] := value end);
   AddSysVar('EE',
      function: variant begin result := sVars[4] end,
      procedure(const value: variant) begin sVars[4] := value end);
   AddSysVar('FF',
      function: variant begin result := sVars[5] end,
      procedure(const value: variant) begin sVars[5] := value end);
   AddSysVar('TIME',
      function: variant begin result := timetostr(now) end,
      nil);
   AddSysVar('DATE',
      function: variant begin result := datetostr(now) end,
      nil);
   AddSysVar('CHARTING',
      function: variant begin result := datawell.isCharting end,
      nil);
   AddSysVar('FOLLOWING',
      function: variant begin result := datawell.IsFollowing end,
      nil);
   AddSysVar('ROOM',
      function: variant begin result := FormMain.roomshortstring end,
      nil);
   AddSysVar('PANIC',
      function: variant begin result := datawell.IsPanicking end,
      nil);
   AddSysCVar('IMAGE', nil);
   AddSysCVar('AVI', nil);
   AddSysCVar('SOUND', nil);
   AddSysCVar('MUSIC', nil);
   AddSysCVar('MWCOMBAT', nil);
   AddSysCVar('MWGUILD', nil);
   AddSysCVar('AUTOTYPER', nil);
   AddSysCVar('SYSTEM', nil);
   AddSysCVar('EXECUTE', nil);
end;

procedure TScripts.LegacyScript(const script: string; kind: integer);
var
   sl: TStringList;
   line: string;
begin
   sl := TStringList.Create;
   try
      sl.Text := script;
      for line in sl do
         FormMain.ParseMain(line, kind);
   finally
      sl.Free;
   end;
end;

function TScripts.externalsFunctionsLegacyAliasFastEval(const args: TExprBaseListExec): Variant;
var
   script, data: string;
   order: integer;
   rev, frev: boolean;
begin
   script := args.AsString[0];
   data := args.AsString[1];
   order := args.AsInteger[2];
   case order of
      0: begin rev := false; frev := false end;
      1: begin rev := true; frev := false end;
      2: begin rev := true; frev := true end;
      else FormMain.SystemText(format('Invalid alias order value. (Order %d)', [order]), 1);
   end;
   FormMain.ExecuteAlias(script, data, CurrentContext, rev, frev);
   result := Null;
end;

function TScripts.externalsFunctionsLegacyScriptFastEval(
  const args: TExprBaseListExec): Variant;
var
   script, kind: string;
   kindVal: integer;
begin
   script := args.AsString[0];
   kind := UpperCase(args.AsString[1]);
   if kind = 'ALIAS' then
      kindVal := 3
   else if kind = 'MACRO' then
      kindVal := 4
   else if kind = 'EVENT' then
      kindVal := 5
   else if kind = 'QUICKCHAR' then
      kindVal := 7
   else if kind = 'TICKER' then
      kindVal := 9
   else kindVal := 1; //typed
   LegacyScript(script, kindVal);
   result := Null;
end;

function TScripts.externalsFunctionsCommandEval(
  const args: TExprBaseListExec): Variant;
var
   data: string;
begin
   data := args.AsString[0];
   FormMain.ParseMain(data, CurrentContext);
end;

function TScripts.externalsFunctionsDebugOutputEval(
  const args: TExprBaseListExec): Variant;
var
   data: string;
begin
   data := args.AsString[0];
   FormMain.SystemText(data, 1);
end;

function TScripts.externalsFunctionsPrintEval(
  const args: TExprBaseListExec): Variant;
var
   data: string;
begin
   data := args.AsString[0];
   FormMain.SendData(data, 999);
end;

function TScripts.externalsFunctionsPrintVarsEval(
  const args: TExprBaseListExec): Variant;
var
   data: string;
begin
   data := args.AsString[0];
   data := Datawell.ReplaceVariables(data);
   FormMain.SendData(data, 999);
end;

procedure TScripts.ResetFunctions;
var
   func: TdwsFunction;
begin
   func := externals.Functions.Add;
   func.Name := 'LegacyScript(const script, kind: string)';
   func.OnFastEval := externalsFunctionsLegacyScriptFastEval;

   func := externals.Functions.Add;
   func.Name := 'LegacyAlias(const script: string; args: string = ''''; order: TAliasOrder = aoNormal)';
   func.OnFastEval := externalsFunctionsLegacyAliasFastEval;

   func := externals.Functions.Add;
   func.Name := 'Print(const data: string)';
   func.OnFastEval := externalsFunctionsPrintEval;

   func := externals.Functions.Add;
   func.Name := 'PrintLn(const data: string)';
   func.OnFastEval := externalsFunctionsPrintEval;

   func := externals.Functions.Add;
   func.Name := 'PrintVars(const data: string)';
   func.OnFastEval := externalsFunctionsPrintVarsEval;

   func := externals.Functions.Add;
   func.Name := 'DebugOutput(const data: string)';
   func.OnFastEval := externalsFunctionsDebugOutputEval;

   func := externals.Functions.Add;
   func.Name := 'Command(const data: string)';
   func.OnFastEval := externalsFunctionsCommandEval;
end;

procedure TScripts.AddFunc(name: string);
var
   func: TdwsFunction;
   exec: TFuncExecutor;
   internalName: string;
begin
   internalName := SafeAliasName(name);
   func := externals.Functions.Add;
   func.Name := internalName + '(args: string = ''''; order: TAliasOrder = aoNormal)';
   exec := TFuncExecutor.Create(name);
   FAliases.Add(exec);
   func.OnFastEval := exec.FastEval;
end;

procedure TScripts.PrepareFunctions(dataset: TDataset);
var
   alias: TField;
begin
   externals.StaticSymbols := false;
   externals.Functions.Clear;
   FAliases.Clear;
   ResetFunctions;
   alias := dataset.FieldByName('alias');
   dataset.First;
   while not dataset.Eof do
   begin
      AddFunc(alias.AsString);
      dataset.Next;
   end;
   externals.StaticSymbols := false;
end;

procedure TScripts.PrepareVars(dataset: TDataset);
var
   vname: TField;
begin
   FAccessors.Clear;
   externals.StaticSymbols := false;
   externals.Variables.Clear;
   vname := dataset.FieldByName('FVariable');
   dataset.First;
   while not dataset.Eof do
   begin
      AddVar(vName.AsString);
      dataset.Next;
   end;
   AddSysVars;

   externals.StaticSymbols := true;
end;

procedure TScripts.RunScript(const script: string);
var
   prog: IdwsProgram;
   i: integer;
   exec: IdwsProgramExecution;
   sl: TStringList;
   output, line: string;
begin
   prog := dws.Compile(script);
   if prog.Msgs.HasErrors then
   begin
      for i := 0 to prog.Msgs.Count - 1 do
         FormMain.SystemText(prog.Msgs.Msgs[i].AsInfo, 1);
      Exit;
   end;
   prog.Execute();
end;

{ TVarAccessor }

constructor TVarAccessor.Create(const name: string);
begin
   FName := name;
end;

procedure TVarAccessor.read(info: TProgramInfo; var value: Variant);
begin
   value := datawell.GetUserVariableValue(FName);
end;

procedure TVarAccessor.write(info: TProgramInfo; const value: Variant);
begin
   datawell.UpdateUserVariable(FName, value);
end;

{ TSystemVarAccessor }

constructor TSystemVarAccessor.Create(const name: string; const reader: TVarReadFunc;
  const writer: TVarWriteProc);
begin
   FReader := reader;
   FWriter := writer;
   FName := name;
end;

procedure TSystemVarAccessor.read(info: TProgramInfo; var value: Variant);
begin
   if assigned(FReader) then
      value := FReader()
   else raise EScriptError.CreateFmt('System variable %s is write-only', [FName]);
end;

procedure TSystemVarAccessor.write(info: TProgramInfo; const value: Variant);
begin
   if assigned(FWriter) then
      FWriter(value)
   else raise EScriptError.CreateFmt('System variable %s is read-only', [FName]);
end;

{ TFuncExecutor }

constructor TFuncExecutor.Create(const name: string);
begin
   Fname := name;
end;

function TFuncExecutor.FastEval(const args: TExprBaseListExec): Variant;
var
   data: string;
   order: integer;
   rev, frev: boolean;
begin
   data := args.AsString[0];
   order := args.AsInteger[1];
   case order of
      0: begin rev := false; frev := false end;
      1: begin rev := true; frev := false end;
      2: begin rev := true; frev := true end;
      else FormMain.SystemText(format('Invalid alias order value. (Alias: %s, Order %d)', [FName, order]), 1);
   end;
   FormMain.DoAlias(FName, data, Scripts.CurrentContext, rev, frev, false);
   result := Null;
end;

end.
